home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / turbusq.pas < prev    next >
Pascal/Delphi Source File  |  1985-06-03  |  8KB  |  258 lines
  1. {$C-}
  2. program Unsqueeze;      { unsqueeze file from in_file to out_file }
  3.  
  4. {
  5.   This program unsqueezes a file which has been squeezed or compressed to
  6.   reduce the space required to store it on disk. The program was converted
  7.   from the original version written for CP/M in the C language.  This program
  8.   can be used to unsqueeze files which have been downloaded from RCP/M systems
  9.   where almost all files are saved in this squeezed format.
  10.  
  11.   The technique used is the Huffman encoding technique which converts the most
  12.   common characters in the input file to a compressed bit stream of data. This
  13.   program unsqueezes such a Huffman encoded file.
  14.  
  15.   PUBLIC DOMAIN - Feel free to distribute this program. Do not distribute it by
  16.   commercial means or make any charge for this pgm.
  17.  
  18.   Version 1.0  - 09/05/82  Scott Loftesness
  19.   Version 1.1  - 01/06/83  Added capability to strip off parity bit if
  20.                            output file is text. Ernie LeMay 71435,730
  21.   Version 1.2  - 07/20/84  converted to Turbo Pascal. Steve Freeman
  22. }
  23.  
  24.  
  25. const
  26.     recognize  = $FF76;
  27.     numvals    = 257;      { max tree size + 1 }
  28.     speof      = 256;      { special end of file marker }
  29.     dle: char  = #$90;
  30.  
  31. type
  32.     tree       = array [0..255,0..1] of integer;
  33.     hexstr     = string[4];
  34.  
  35. var
  36.     in_file, out_file: file of char;
  37.     in_FN: string[30];
  38.     dnode: tree;
  39.     inchar, curin, filecksum, bpos, i, repct, numnodes: integer;
  40.     c, lastchar: char;
  41.     origfile: string[14];
  42.     docfile, eofin, abort: boolean;
  43.     abortM: string[50];
  44.     linecnt : integer;
  45.  
  46.  
  47. { iftext -- find out if output file is text and return true if so. EL }
  48. function iftext : boolean;
  49.   var answer: char;
  50.   begin
  51.     repeat
  52.       write('Is the output file a text file?  ');
  53.       read(kbd,answer);
  54.       answer := upcase(answer);
  55.     until (answer in ['Y','N']);
  56.     writeln(answer);
  57.     if answer='Y'
  58.       then iftext:=true
  59.       else iftext:=false;
  60.   end;
  61.  
  62.  
  63. function hex(num: integer): hexstr;
  64.   var i, j: integer;
  65.       h: string[16];
  66.       str: hexstr;
  67.   begin
  68.     str := '0000';   h := '0123456789ABCDEF';   j := num;
  69.     for i:=4 downto 1
  70.       do begin
  71.            str[i] := h[(j and 15)+1];
  72.            j := j shr 4;
  73.          end;
  74.     hex := str;
  75.   end;
  76.  
  77.  
  78. { getw - get a word value from the input file }
  79. function getw: integer;
  80.     var in1,in2: char;
  81.   begin
  82.     read(in_file,in1,in2);
  83.     getw := ord(in1) + ord(in2) shl 8;
  84.   end;
  85.  
  86.  
  87. function getc: integer;
  88.   var ch: char;
  89.     iochk : integer;
  90.   begin
  91.   {$I-}
  92.   read(in_file,ch);
  93.   {$I+}
  94.   iochk := ioresult;
  95.   if iochk = 0 then
  96.     getc := ord(ch)
  97.   else if iochk = 99 then
  98.     begin
  99.     writeln; writeln('Unexpected end-of-file, aborting.');
  100.     writeln('Output file is damaged.');
  101.     close(out_file);
  102.     halt;
  103.     end
  104.   else
  105.     begin
  106.     writeln;  writeln('I/O error # ', iochk ,' on read, aborting.');
  107.     writeln('Output file is damaged.');
  108.     close(out_file);
  109.     halt;
  110.     end;
  111.   end;
  112.  
  113. procedure initialize;
  114.   var str: string[14];
  115.   begin
  116.     abort := false;     { no error conditions presently exist }
  117.     repct:=0;   bpos:=99;   origfile:='';   eofin:=false;
  118.     clrscr;   gotoxy(1,5);   write('Enter the file to unsqueeze:');   readln(in_FN);
  119.     assign(in_file,in_FN);
  120.     {$I-}
  121.     reset(in_file);
  122.     {$I+}
  123.     if (IOresult<>0) then i := 0
  124.                      else if eof(in_file)
  125.                             then i := 0
  126.                             else i := getw;
  127.     if (recognize <> i)
  128.       then begin
  129.              abort  := true;
  130.              abortM := 'File is not a squeezed file';
  131.              numnodes := -1;
  132.            end
  133.       else begin
  134.              filecksum := getw;     { get checksum from chars 2 - 3 of file }
  135.              repeat    { build original file name }
  136.                  inchar:=getc;
  137.                  if inchar <> 0
  138.                    then origfile := origfile + chr(inchar);
  139.                until inchar = 0;
  140.              writeln('Original file name is ',origfile);
  141.              write('Output to (return to default) ? ');
  142.              readln(str);   if length(str)=0 then str:=origfile;
  143.              assign(out_file,str);   rewrite(out_file);
  144.              numnodes:=ord(getw); { get the number of nodes in this files tree }
  145.              if (numnodes<0) or (numnodes>=numvals)
  146.                then begin
  147.                       abort  := true;
  148.                       abortM := 'File has invalid decode tree size';
  149.                     end;
  150.            end;
  151.     if not(abort)
  152.       then begin
  153.              dnode[0,0]:= -(speof+1);
  154.              dnode[0,1]:= -(speof+1);
  155.              numnodes:=numnodes-1;
  156.              for i:=0 to numnodes
  157.                do begin
  158.                     dnode[i,0]:=getw;
  159.                     dnode[i,1]:=getw;
  160.                   end;
  161.              { following is for test }
  162.              {for i:=0 to numnodes
  163.                do writeln(lst,'#',i:3,' ',hex(dnode[i,0]),' ',hex(dnode[i,1]));}
  164.            end;
  165.   end;
  166.  
  167. procedure dochar(c: char;  text: boolean);
  168.   var iochk : integer;
  169.   begin
  170.     if text then c:=chr(ord(c) and $7F); {strip off parity bit}
  171.     {$I-}
  172.     write(out_file,c);
  173.     {$I+}
  174.     iochk := ioresult;
  175.     if iochk = 0 then
  176.       begin ; end
  177.     else
  178.       begin
  179.       writeln;  writeln('I/O error # ', iochk, ' on write......  Aborting.');
  180.       writeln('Output file is damaged.');
  181.       close(out_file);
  182.       halt;
  183.       end;
  184.   end;
  185.  
  186. function getuhuff: char;
  187. var i: integer;
  188.   begin
  189.     i:=0;
  190.     repeat
  191.         bpos:=bpos+1;
  192.         if bpos>7 then begin
  193.                          curin := getc;
  194.                          bpos:=0;
  195.                        end
  196.                   else curin := curin shr 1;
  197.         i := ord(dnode[i,ord(curin and $0001)]);
  198.       until (i<0);
  199.     i := -(i+1);
  200.     if i=speof
  201.       then begin
  202.              eofin:=true;
  203.              getuhuff:=chr(26)
  204.            end
  205.       else getuhuff:=chr(i);
  206.   end;
  207.  
  208. function getcr: char;
  209. var c: char;
  210.   begin
  211.     if (repct>0)
  212.       then begin
  213.              repct:=repct-1;
  214.              getcr:=lastchar;
  215.            end
  216.       else begin
  217.              c:=getuhuff;
  218.              if c<>dle
  219.                then begin
  220.                       getcr:=c;
  221.                       lastchar:=c;
  222.                     end
  223.                else begin
  224.                       repct:=ord(getuhuff);
  225.                       if repct=0 then getcr:=dle
  226.                                  else begin
  227.                                         repct:=repct-2;
  228.                                         getcr:=lastchar;
  229.                                       end;
  230.                     end;
  231.            end;
  232.   end; {getcr}
  233.  
  234. begin { main }
  235.   initialize;
  236.   if not(abort)
  237.     then begin
  238.            docfile := iftext;
  239.            writeln(output,'Tree loaded sucessfully. Un-squeezing begins...');
  240.            linecnt := 0;
  241.            while not(eof(in_file)) or not(eofin)
  242.              do begin
  243.                   c:=getcr;
  244.                   if (linecnt mod 2500) = 0 then
  245.                     begin
  246.                     writeln;
  247.                     write(' <', linecnt : 6, '>');
  248.                     end;
  249.                   if (linecnt mod 50) = 0 then write('.');
  250.                   linecnt := linecnt + 1;
  251.                   dochar(c,docfile);
  252.                 end;
  253.            close(out_file);
  254.          end
  255.     else writeln('Error -- ',AbortM);
  256.   close(in_file);
  257. end.
  258.